Visual Basic Toolbox/Visual Basic Toolbox (P.I.E.)(1996).ISO/forms/frmwiz/frmwizrd.bas

BASIC Source File | 1995-01-15 | 19.4 KB | 458 lines

Option Explicit
Global erraction As Integer
Global Inst%
Global ret As Variant
Global db As database
Global NewRecordSource As Integer
Global Quote As String
Global EndingIt As Integer
Global aiFldSize() As Long       ' Field sizes
Global RequiredFieldsComplete As String     ' Indication that required fields are present

Global stemplate As String, sForm As String    ' names for template and form files
Global sFormLine As String, msg As String
Global indent As Integer           ' number spaces to indent line
Global iNumLabelLines As Integer   ' number of lines in label control definition
Global sLabelLines() As String     ' lines in label definition
Global iNumTextLines As Integer    ' number of lines in Text control definition
Global sTextLines() As String      ' lines in textbox definition
Global dSvLabel1Top As Double      ' save area for label1 top
Global dSvLabel1Left As Double     ' save area for label1 left
Global dSvLabel2Top As Double      ' save area for label2 top
Global dLabelInc As Double         ' amount to increment each label top by
Global dSvText1Top As Double       ' save area for textbox1 top
Global dSvText1Left As Double      ' save area for textbox1 left
Global dSvText2Top As Double       ' save area for textbox2 top
Global dTextInc As Double          ' amount to increment each textbox top by




' API declares for 3d common controls
Declare Function GetModuleUsage Lib "KERNEL" (ByVal InstanceID%) As Integer
Declare Function GetModuleHandle Lib "Kernel" (ByVal ModuleName As String) As Integer
Declare Function Ctl3dAutoSubclass Lib "Ctl3D.DLL" (ByVal hInst As Integer) As Integer
Declare Function Ctl3dRegister Lib "Ctl3D.DLL" (ByVal hInst As Integer) As Integer
Declare Function Ctl3dUnregister Lib "Ctl3D.DLL" (ByVal hInst As Integer) As Integer

Declare Function GetPrivateProfileInt Lib "Kernel" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal nDefault As Integer, ByVal lpFileName As String) As Integer
Declare Function GetPrivateProfileString Lib "Kernel" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Integer, ByVal lpFileName As String) As Integer
Declare Function WritePrivateProfileString Lib "Kernel" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpString As String, ByVal lplFileName As String) As Integer

'Note: IniFile should be in Windows Directory

'Example calling Code to create or update ini -------------------------------------------------------------------------------------
    'IniFileName$ = "MyINI.INI"        'name of ini file
    'AppName$ = "MyApp"             'Name of application or section heading
    'KeyName$ = "MyNumber"          'Keyword or variable name
    'NewVal$="MyNewValue"           'if Numeric value convert it to string
    'SaveIni AppName$, IniFileName$, KeyName$, NewVal$

' Example Calling Code to Read Numeric Variable ------------------------------------------------------------------------------
    'IniFileName$ = "MyINI.INI"        'name of ini file
    'AppName$ = "MyApp"             'Name of application or section heading
    'KeyName$ = "MyNumber"          'Keyword or variable name
    'nDefault = 0                   'Default numeric value (for numeric variables)
    'Numeric%=TRUE                  'Tell it we are looking for numeric value
    'ReadIni AppName$, KeyName$, nDefault, DefaultStr$, ReturnStr$, Numeric%, IniFileName$

' Example Calling Code to Read String Variable ------------------------------------------------------------------------------
    'IniFileName$ = "MyINI.INI"        'name of ini file
    'AppName$ = "MyApp"             'Name of application or section heading
    'KeyName$ = "MyString"          'Keyword or variable name
    'DefaultStr$ = "DefaultString"  'Default string        (for String variables)
    'Dim RetStr As String * 255     'Create an empty string to be filled
    'nSize% = 255                   'uncertain - possibly length of fill string
    'Numeric%=FALSE                 'Tell it we are looking for a string
    'ReadIni AppName$, KeyName$, nDefault, DefaultStr$, ReturnStr$, Numeric%, IniFileName$

Sub Cancel3D ()
    ' end the 3D effects
    Inst% = GetModuleHandle(App.EXEName)  ' Get program's ModuleHandle.
    ret = Ctl3dUnregister(Inst%)          ' Unregister the program.

End Sub

Sub EndItNow ()
    On Error Resume Next
    EndingIt = True
    db.Close        ' Close the database
    MainForm.Show MODELESS
    Unload DataForm     ' Unload all possible forms

End Sub

Sub GotEndOfForm ()
    Dim fld As Integer
    Dim sFldName As String      ' Field name
    Dim sFldCaption As String   ' Field Caption for label
    Dim lnFldSize As Long       ' Field size
    Dim lnFldWidth As Long      ' Field control width
    Dim sCtrlLabel As String    ' Label for controls
    Dim lFldSameLine As Integer ' Field go on same line?
    Dim dFldTop As Double       ' Top of field control
    Dim dFldLeft As Double      ' Left of field control
    Dim dLblTop As Double       ' Top of label control
    Dim dLblLeft As Double      ' Left of label control
    Dim i As Integer
    '   got the end of form line
    On Error GoTo EndOfFormerr


    If dSvText1Top = 0 Or dTextInc = 0 Then
        Beep
        Screen.MousePointer = DEFAULT
        MsgBox "The data field control was either not specified or specified incorrectly in the template!", 0 + 48 + 0 + 0, "Form Save Error"
        DataForm.TxtFrmName.SetFocus
        Exit Sub
    End If

    dFldTop = dSvText1Top - dLabelInc       ' Get top of first field control
    dLblTop = dSvLabel1Top - dTextInc       ' and label control
    ' output the label and field controls from the data saved earlier
    For fld = 1 To DataForm.GrdFields.Rows - 1      ' Do it for each field in grid
        DataForm.GrdFields.Row = fld
        DataForm.GrdFields.Col = 0
        sFldName = DataForm.GrdFields.Text
        'Create Control Label from field name less special chars and spaces
        sCtrlLabel = ""
        For i = 1 To Len(sFldName)
            If Mid$(sFldName, i, 1) > "/" And Mid$(sFldName, i, 1) < "{" Then
                sCtrlLabel = sCtrlLabel & Mid$(sFldName, i, 1)
            End If
        Next i
        DataForm.GrdFields.Col = 1
        sFldCaption = DataForm.GrdFields.Text
        DataForm.GrdFields.Col = 2
        If DataForm.GrdFields.Text = "Yes" Then
            lFldSameLine = True
        Else
            lFldSameLine = False
        End If
        DataForm.GrdFields.Col = 3
        lnFldSize = Val(DataForm.GrdFields.Text)
        lnFldWidth = DataForm.TextWidth(String$(lnFldSize, "x"))
        If lnFldWidth > Screen.Width - dSvText1Left - 300 Then
            lnFldWidth = Screen.Width - dSvText1Left - 300
        End If
        indent = 3
        ' Output the label for the current field
        For i = 0 To iNumLabelLines
            Select Case True
            Case InStr(1, sLabelLines(i), "Begin ") <> 0        ' Begin line
                Print #2, Spc(indent); sLabelLines(i) & "Lbl" & sCtrlLabel
                indent = indent + 3
            Case InStr(1, sLabelLines(i), "Caption ") <> 0      ' Caption = line
                Print #2, Spc(indent); Left$(sLabelLines(i), InStr(1, sLabelLines(i), "=") + 2) & Quote & sFldCaption & Quote
            Case InStr(1, sLabelLines(i), "Top ") <> 0          ' Top = line
                If Not lFldSameLine Then
                    dLblTop = dLblTop + dLabelInc       ' Increment top for next line
                End If
                Print #2, Spc(indent); Left$(sLabelLines(i), InStr(1, sLabelLines(i), "=") + 2) & Str$(dLblTop)
            Case InStr(1, sLabelLines(i), "Alignment") <> 0         ' Alignment = line
                If lFldSameLine Then            ' If field on same line
                    Print #2, Spc(indent); Left$(sLabelLines(i), InStr(1, sLabelLines(i), "=") + 2);
                    Print #2, "  0    ' Left Justify"
                Else
                    Print #2, Spc(indent); sLabelLines(i)       ' Use defined alignment
                End If
            Case InStr(1, sLabelLines(i), "Left ") <> 0         ' Left = line
                Print #2, Spc(indent); Left$(sLabelLines(i), InStr(1, sLabelLines(i), "=") + 2);
                If Not lFldSameLine Then
                    dLblLeft = dSvLabel1Left   ' Reset left if not on same line
                Else
                    dLblLeft = dFldLeft
                End If
                Print #2, Str$(dLblLeft)
                dLblLeft = dLblLeft + DataForm.TextWidth(sFldCaption) + DataForm.TextWidth("   ")     ' Set left at next avail pos
            Case InStr(1, sLabelLines(i), "End") <> 0        ' End line
                indent = indent - 3
                Print #2, Spc(indent); sLabelLines(i)
            Case Else                                           ' All other lines
                Print #2, Spc(indent); sLabelLines(i)
            End Select
        Next i

        ' Output the field control for the current field
        indent = 3
        For i = 0 To iNumTextLines
            Select Case True
            Case InStr(1, sTextLines(i), "Begin ") <> 0        ' Begin line
                Print #2, Spc(indent); sTextLines(i) & "Txt" & sCtrlLabel
                indent = indent + 3
            Case InStr(1, sTextLines(i), "Top ") <> 0          ' Top = line
                If Not lFldSameLine Then
                    dFldTop = dFldTop + dTextInc       ' Increment top for next line
                End If
                Print #2, Spc(indent); Left$(sTextLines(i), InStr(1, sTextLines(i), "=") + 2) & Str$(dFldTop)
            Case InStr(1, sTextLines(i), "Left ") <> 0         ' Left = line
                Print #2, Spc(indent); Left$(sTextLines(i), InStr(1, sTextLines(i), "=") + 2);
                If Not lFldSameLine Then
                    dFldLeft = dSvText1Left   ' Reset left if not on same line
                Else
                    dFldLeft = dLblLeft
                End If
                Print #2, Str$(dFldLeft)
                dFldLeft = dFldLeft + lnFldWidth + DataForm.TextWidth("   ")    ' Set left at next avail pos
            Case InStr(1, sTextLines(i), "DataSource ") <> 0          ' DataSource = line
                Print #2, Spc(indent); Left$(sTextLines(i), InStr(1, sTextLines(i), "=") + 2) & Quote & DataForm.TxtName.Text & Quote
            Case InStr(1, sTextLines(i), "DataField ") <> 0          ' DataField = line
                Print #2, Spc(indent); Left$(sTextLines(i), InStr(1, sTextLines(i), "=") + 2) & Quote & sFldName & Quote
            Case InStr(1, sTextLines(i), "MaxLength ") <> 0          ' MaxLength = line
                Print #2, Spc(indent); Left$(sTextLines(i), InStr(1, sTextLines(i), "=") + 2) & Str$(lnFldSize)
            Case InStr(1, sTextLines(i), "Width ") <> 0          ' Width = line
                Print #2, Spc(indent); Left$(sTextLines(i), InStr(1, sTextLines(i), "=") + 2) & Str$(lnFldWidth)
            Case InStr(1, sTextLines(i), "End") <> 0        ' End line
                indent = indent - 3
                Print #2, Spc(indent); sTextLines(i)
            Case Else                                           ' All other lines
                Print #2, Spc(indent); sTextLines(i)
            End Select
        Next i

    Next fld


    ' output the end of form definition line
    Print #2, sFormLine    ' Output the end line

    Exit Sub

EndOfFormerr:
    erraction = RB_ErrorHandler("GenForm", "GotEndOfForm")
    Select Case erraction
    Case 1
        Resume 0      ' Retry option selected
    Case 2
        Resume Next   ' Ignore option selected
    End Select

End Sub

Sub ReadIni (AppName$, KeyName$, nDefault, DefaultStr$, ReturnStr$, Numeric%, IniFileName$)
    Dim nSize%, lenRetString%

' Read data from Private Profile (.ini) File

    If Numeric% Then    'we are looking for integer input
        Numeric% = GetPrivateProfileInt(AppName$, KeyName$, nDefault, IniFileName$)
    Else
        Dim RetStr As String * 255 'Create an empty string to be filled
        nSize% = 255               'uncertain - possibly length of fill string
        lenRetString% = GetPrivateProfileString(AppName$, KeyName$, DefaultStr$, RetStr$, nSize%, IniFileName$)
        ReturnStr$ = Left$(RetStr$, lenRetString%)

    End If


End Sub

Sub SaveControl ()
    ' output the data for a control other than fields and data control
    On Error GoTo svcontrolerr

    Print #2, Spc(indent); sFormLine    ' Output the begin line
    indent = indent + 3                 ' indent rest 1 position
    Do While InStr(1, sFormLine, "End", 1) = 0
        Input #1, sFormLine             ' Get the next line
        If InStr(1, sFormLine, "End", 1) = 0 Then   ' if not end of control definition
            Print #2, Spc(indent); sFormLine    ' Output each line of control definition
        End If
    Loop
    indent = indent - 3                 ' Return indent back
    Print #2, Spc(indent); sFormLine    ' Output the end line

    Exit Sub

svcontrolerr:
    erraction = RB_ErrorHandler("GenForm", "SaveControl")
    Select Case erraction
    Case 1
        Resume 0      ' Retry option selected
    Case 2
        Resume Next   ' Ignore option selected
    End Select

End Sub

Sub SaveDataCtrl ()
    ' Output the data for the data control
    On Error GoTo svDataerr
    ' Output beginning line with specified name
    Print #2, Spc(indent); "Begin Data " & DataForm.TxtName.Text
    indent = indent + 3     ' Indent data definition lines
    Input #1, sFormLine     ' Get the next line of input

    Do While InStr(1, sFormLine, "End", 1) = 0
        Select Case True
        Case InStr(1, sFormLine, "Caption ") <> 0   ' Caption = line
            Print #2, Spc(indent); "Caption  = "; Quote & DataForm.TxtCaption.Text & Quote
        Case InStr(1, sFormLine, "DatabaseName ") <> 0   ' Database name = line
            Print #2, Spc(indent); "DatabaseName  = "; Quote & DataForm.TxtDBName.Text & Quote
        Case InStr(1, sFormLine, "RecordSource ") <> 0   ' RecordSource = line
            Print #2, Spc(indent); "RecordSource  = " & Quote & DataForm.LstRecSrce.Text & Quote
        Case Else
            Print #2, Spc(indent); sFormLine        ' Output any unrecognized lines as is
        End Select

        Input #1, sFormLine
    Loop
    indent = indent - 3     ' Reset indentation
    Print #2, Spc(indent); sFormLine        ' Output the end line

    Exit Sub

svDataerr:
    erraction = RB_ErrorHandler("GenForm", "SaveDataCtrl")
    Select Case erraction
    Case 1
        Resume 0      ' Retry option selected
    Case 2
        Resume Next   ' Ignore option selected
    End Select

End Sub

Sub SaveField1 ()
    Dim i As Integer
    ' Save the data for the first field textbox for later use
    On Error GoTo svField1err
    iNumLabelLines = 0
    i = -1
    sFormLine = Left$(sFormLine, Len(sFormLine) - 4)    ' Drop Fld1 from begin line
    Do
        i = i + 1       ' increment number lines in control definition
        ReDim Preserve sTextLines(i) As String
        sTextLines(i) = sFormLine      ' Save the line
        If InStr(1, sFormLine, "Top ") <> 0 Then        ' Is this Top = line
            dSvText1Top = Val(Mid$(sFormLine, InStr(4, sFormLine, "=") + 1))   ' Save value of top
            dTextInc = dSvText2Top - dSvText1Top        ' Calc diff between top of fields
        End If
        If InStr(1, sFormLine, "Left ") <> 0 Then        ' Is this Left = line
            dSvText1Left = Val(Mid$(sFormLine, InStr(4, sFormLine, "=") + 1))   ' Save value of Left
        End If
        Input #1, sFormLine
    Loop While InStr(1, sFormLine, "End", 1) = 0
    i = i + 1       ' increment number lines in control definition
    ReDim Preserve sTextLines(i) As String
    sTextLines(i) = sFormLine      ' Save the End line
    iNumTextLines = i


    Exit Sub

svField1err:
    erraction = RB_ErrorHandler("GenForm", "SaveField1")
    Select Case erraction
    Case 1
        Resume 0      ' Retry option selected
    Case 2
        Resume Next   ' Ignore option selected
    End Select

End Sub

Sub SaveField2 ()
    ' Save the data for the first label for later use
    On Error GoTo svField2err
    Do While InStr(1, sFormLine, "End", 1) = 0
        If InStr(1, sFormLine, "Top ") <> 0 Then        ' Is this top = line
            dSvText2Top = Val(Mid$(sFormLine, InStr(4, sFormLine, "=") + 1))   ' Save value of top
            dTextInc = dSvText2Top - dSvText1Top        ' Calc diff between top of fields
        End If
        Input #1, sFormLine
    Loop

    Exit Sub

svField2err:
    erraction = RB_ErrorHandler("GenForm", "SaveField2")
    Select Case erraction
    Case 1
        Resume 0      ' Retry option selected
    Case 2
        Resume Next   ' Ignore option selected
    End Select

End Sub

Sub SaveIni (AppName$, IniFileName$, KeyName$, NewVal$)
    Dim ResultCode%

    ' Update INI file

    ResultCode% = WritePrivateProfileString(AppName$, KeyName$, NewVal$, IniFileName$)
    If ResultCode% = 0 Then
        Beep
        MsgBox "Error updating INI file!", 16, "ERROR!"
    End If



End Sub

Sub SaveLabel1 ()
    Dim i As Integer        ' number of lines in control definition

    ' Save the data for the first label for later use
    On Error GoTo svlabel1err
    i = -1
    sFormLine = Left$(sFormLine, Len(sFormLine) - 4)    ' Drop Lbl1 from begin line
    Do
        i = i + 1       ' increment number lines in control definition
        ReDim Preserve sLabelLines(i) As String
        sLabelLines(i) = sFormLine      ' Save the line
        If InStr(1, sFormLine, "Top ") <> 0 Then        ' Is this top = line
            dSvLabel1Top = Val(Mid$(sFormLine, InStr(4, sFormLine, "=") + 1))   ' Save value of top
            dLabelInc = dSvLabel2Top - dSvLabel1Top     ' Calculate difference between top of labels
        End If
        If InStr(1, sFormLine, "Left ") <> 0 Then        ' Is this Left = line
            dSvLabel1Left = Val(Mid$(sFormLine, InStr(4, sFormLine, "=") + 1))   ' Save value of Left
        End If
        Input #1, sFormLine
    Loop While InStr(1, sFormLine, "End", 1) = 0
    i = i + 1       ' increment number lines in control definition
    ReDim Preserve sLabelLines(i) As String
    sLabelLines(i) = sFormLine      ' Save the End line
    iNumLabelLines = i

    Exit Sub

svlabel1err:
    erraction = RB_ErrorHandler("GenForm", "SaveLabel1")
    Select Case erraction
    Case 1
        Resume 0      ' Retry option selected
    Case 2
        Resume Next   ' Ignore option selected
    End Select

End Sub

Sub SaveLabel2 ()
    ' Use the top of the second label to determine the increment
    ' for successive field labels
    On Error GoTo svlabel2err
    Do While InStr(1, sFormLine, "End", 1) = 0
        If InStr(1, sFormLine, "Top ") <> 0 Then        ' Is this top = line
            dSvLabel2Top = Val(Mid$(sFormLine, InStr(4, sFormLine, "=") + 1))   ' Save value of top
            dLabelInc = dSvLabel2Top - dSvLabel1Top     ' Calculate difference between top of labels
        End If
        Input #1, sFormLine
    Loop

    Exit Sub

svlabel2err:
    erraction = RB_ErrorHandler("GenForm", "SaveLabel2")
    Select Case erraction
    Case 1
        Resume 0      ' Retry option selected
    Case 2
        Resume Next   ' Ignore option selected
    End Select


End Sub